Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/usrgrp32.fr_/usrgrp32.fr

Text File | 1995-09-04 | 6KB | 216 lines

VERSION 4.00
Begin VB.Form frmMain
   BackColor       =   &H00C0C0C0&
   Caption         =   "Add User to Group"
   ClientHeight    =   2100
   ClientLeft      =   1890
   ClientTop       =   2055
   ClientWidth     =   4770
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   2505
   Left            =   1830
   LinkTopic       =   "Form1"
   ScaleHeight     =   2100
   ScaleWidth      =   4770
   Top             =   1710
   Width           =   4890
   Begin VB.CommandButton cmdShowUsers
      Caption         =   "&Show Users"
      Enabled         =   0   'False
      Height          =   375
      Left            =   3240
      TabIndex        =   6
      Top             =   600
      Width           =   1215
   End
   Begin VB.ComboBox cboGroups
      Height          =   300
      Left            =   960
      Sorted          =   -1  'True
      Style           =   2  'Dropdown List
      TabIndex        =   4
      Top             =   600
      Width           =   2115
   End
   Begin VB.ComboBox cboUsers
      Height          =   300
      Left            =   990
      Sorted          =   -1  'True
      Style           =   2  'Dropdown List
      TabIndex        =   2
      Top             =   120
      Width           =   2115
   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "Cl&ose"
      Height          =   555
      Left            =   2520
      TabIndex        =   1
      Top             =   1200
      Width           =   1755
   End
   Begin VB.CommandButton cmdAddUser
      Caption         =   "&Add User"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   555
      Left            =   480
      TabIndex        =   0
      Top             =   1200
      Width           =   1755
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Group"
      Height          =   195
      Left            =   180
      TabIndex        =   5
      Top             =   660
      Width           =   525
   End
   Begin VB.Label Label2
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&User:"
      Height          =   195
      Left            =   240
      TabIndex        =   3
      Top             =   180
      Width           =   465
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetPrivateProfileString _
    Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpSectionName As String, _
    ByVal lpKeyName As Any, ByVal lpDefault As String, _
    ByVal lpReturnedString As String, ByVal Size As Integer, _
    ByVal lpFileName As String) As Integer

Private Sub cboGroups_Click()
    cmdAddUser.Enabled = IIf(cboUsers.ListIndex = -1 Or cboGroups.ListIndex = -1, False, True)
    cmdShowUsers.Enabled = IIf(cboGroups.ListIndex = -1, False, True)
End Sub
Private Sub cboUsers_Click()
    cmdAddUser.Enabled = IIf(cboUsers.ListIndex = -1 Or cboGroups.ListIndex = -1, False, True)
End Sub

Private Sub cmdShowUsers_Click()
    frmUsers.Tag = cboGroups.Text
    frmUsers.Show 1
End Sub

Private Sub Form_Load()
    Dim myUser As String, myPass As String
    Dim winDir As String * 128
    Dim dirLen As Integer

    On Error GoTo LoadError

     ' Set the user and passwords for initial login.
    myUser = "Admin"
    myPass = "theboss"

    ' read VBDBHT.INI to get the name of the system database,
    ' then assign that name to the SystemDB property
    DBEngine.SystemDB = GetSystemDatabase()

    ' log in
    DBEngine.DefaultUser = myUser
    DBEngine.DefaultPassword = myPass

    FillUserList
    FillGroupList

Exit Sub
LoadError:
    MsgBox Err & " " & Error$
End

End Sub

Private Sub cmdAddUser_Click()
    Dim newGroup As Group
    Dim thePID As String
    Dim usr As User

    On Error GoTo ChangeError

    ' If the user has not selected both a user and a group, generate an error
    If cboUsers.ListIndex = -1 Then Error 32765
    If cboGroups.ListIndex = -1 Then Error 32764

    ' Add the user to the designated group.
    Set usr = DBEngine.Workspaces(0).Groups(cboGroups.Text).CreateUser(cboUsers.Text)
    DBEngine.Workspaces(0).Groups(cboGroups.Text).Users.Append usr

    ' No errors, so must have been successful.
    MsgBox "User " & cboUsers.Text & " added to " & cboGroups.Text, vbInformation
Exit Sub

ChangeError:
    Dim msg As String
    Select Case Err.Number
        Case 3032
            msg = "User " & cboUsers.Text & " already belongs to Group " & cboGroups.Text
        Case 32765
            msg = "You have not selected a user."
        Case 32764
            msg = "You have not selected a group."
        Case Else
            msg = Err.Description
    End Select
    MsgBox msg, vbExclamation
End Sub

Sub FillUserList()
    Dim usr As User

    For Each usr In DBEngine.Workspaces(0).Users
        If UCase$(usr.Name) <> "CREATOR" And UCase$(usr.Name) <> "ENGINE" Then
            cboUsers.AddItem usr.Name
        End If
    Next
End Sub
Sub FillGroupList()
    Dim grp As Group

    For Each grp In DBEngine.Workspaces(0).Groups
        cboGroups.AddItem grp.Name
    Next
End Sub
Private Sub cmdClose_Click()
    End
End Sub

Private Function GetSystemDatabase() As String
    ' Returns the name of the system directory

    Const INI_FILENAME = "VBDBHT.INI"
    Const MAX_PATH = 128

    Dim lpReturnedString As String * MAX_PATH
    Dim bytesBack As Integer

    bytesBack = GetPrivateProfileString("Options", _
        "SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
    GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")

End Function